;;;; RLlib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)

(defparameter *base-dir* "")

(defun path->file (subpathname)
  (namestring (merge-pathnames subpathname *base-dir*)))

(defun get-base-dir (path)
  (merge-pathnames path
		   #+asdf (asdf:component-pathname (asdf:find-system :skirmish))
		   #-asdf *default-pathname-defaults*))
 
		

;;;============================================================================
;;; Directional keys
;;;============================================================================
(defun key->direction (key)
  (case key
    ((:sdlk-kp1)             '( -1 -1))
    ((:sdlk-kp2 :sdlk-down)  '( 0  -1))
    ((:sdlk-kp3)             '( +1 -1))
    ((:sdlk-kp4 :sdlk-left)  '( -1 0))
    ((:sdlk-kp6 :sdlk-right) '( +1 0))
    ((:sdlk-kp7)             '( -1 +1))
    ((:sdlk-kp8 :sdlk-up)    '( 0 +1))
    ((:sdlk-kp9)              '( +1 +1))
    (t nil)))


;;;============================================================================
;;; General Utils
;;;============================================================================

(defun call-some (funcs &rest lambda-list)
  (some (compose #'identity #'(lambda (c) (when c (apply c lambda-list)))) funcs))

(defun call-every (funcs &rest lambda-list)
  (every #'(lambda (c) (when c (apply c lambda-list))) funcs))

;; Paul Graham, 'ANSI Common Lisp'
(defmacro random-choice (&rest choices)
  `(case (random ,(length choices))
     ,@(let ((key -1))
	    (mapcar #'(lambda (choice) `(,(incf key) ,choice)) choices))))

(defun reduce-adjacent (test reducer list)
  (cond
    ((funcall test (first list) (second list))
     (reduce-adjacent test reducer (cons (funcall reducer (first list) (second list))
					 (cddr list))))
    ((cadr list)
     (cons (first list) (reduce-adjacent test reducer (rest list))))
    (t list)))

(defun group (source n)
  (if (zerop n) (error "zero length"))
  (labels ((rec (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (rec rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

(defun list->strings (list pass-thru-type &optional (converter #'identity))
  "Turn an atom into a list, then convert each item in the list 
into a string representation. PASS-THRU-TYPE type is not printed to string. 
CONVERTER function is called on each PASS-THRU-TYPE (defaults to #'IDENTITY)"
  (loop
       for item in list
       collect (cond
		 ((typep item pass-thru-type) (funcall converter item))
		 ((stringp item) item)
		 (t (princ-to-string item)))))


(defun mksymb (data &optional (package #. (find-package "KEYWORD")))
  (intern (apply #'strcat (mapcar #'mkstring-upcase (mklist data))) package))

(defun mklist (item)
  (if (not (listp item))
      (list item)
      item))

(defun mklist-list (list)
  (let ((list2 (mklist list)))
    (if (not (listp (car list)))
	(list list2)
	list2)))

(defun mkstring (item)
  (if (not (stringp item))
      (format nil "~A" item)
      item))

(defun mkstring-upcase (item)
  (format nil "~:@(~A~)" item))

(defmacro push-list (list/item place)
  (let ((i (gensym)))
    `(progn
       (dolist (,i (reverse (mklist ,list/item)))
	 (push ,i ,place))
       ,place)))

  
(defmacro bif (result-name test then-form &optional else-form)
  `(let ((,result-name ,test))
     (if ,result-name
	 ,then-form
	 ,else-form)))


(defmacro bwhen (result-name test &rest then-form)
  `(let ((,result-name ,test))
     (when ,result-name
       ,@then-form)))


(defmacro bunless (result-name test &rest then-form)
  `(let ((,result-name ,test))
     (unless ,result-name
       ,@then-form)))

(defun iota2 (start end)
  (loop for i from start to end collect i))

(defun strcat (&rest args)
  (if (every #'stringp args)
      (apply #'concatenate 'string args)
      (format nil "~{~A~}" args)))


(defun slurp-file (filename)
  (with-open-file (file filename :direction :input :if-does-not-exist :error)
    (read file)))

;;;============================================================================
;;; English text utils
;;;============================================================================

(defgeneric describe (obj &optional definite)
  (:documentation "string returning description of OBJ"))

(defgeneric gender (obj)
  (:documentation "gender :male | :female | :neuter"))

(defun vowelp (char)
  (find char "aeiou"))

(defun punctuationp (char)
  (find char " .,!?:;"))


(defparameter *irregular-words* (make-hash-table :test #'equal))
(loop for (word plural) on
     '("ox" "oxen" "are" "is" "cod" "cod" "elk" "elk" "pro" "pros"
       "beef" "beeves" "carp" "carp" "have" "has" "mews" "mews" "news" "news"
       "tuna" "tuna" "afrit" "afriti" "bison" "bison" "bream" "bream"
       "child" "children" "cherub" "cherubim" "corps" "corps" "djinn" "djinn"
       "focus" "foci" "goose" "geese" "guano" "guanos" "index" "indices"
       "money" "monies" "mouse" "mice" "mumak" "mumakil" "rhino" "rhinos"
       "sinus" "sinus" "swine" "swine" "trout" "trout" "afreet" "afreeti"
       "armour" "armour" "bonobo" "bonobos" "debris" "debris"
       "efreet" "efreeti" "eland" "eland" "fungus" "fungi" "radius" "radiii"
       "salmon" "salmon" "seraph" "seraphim" "series" "series"
       "shears" "shears" "sphynx" "sphynxes" "status" "status"
       "vortex" "vortices" "albino" "albinos" "gallows" "gallows"
       "incubus" "incubi" "inferno" "infernos" "mongoose" "mongooses"
       "pincers" "pincers" "species" "species" "whiting" "whiting"
       "breeches" "breeches" "britches" "britches" "commando" "commandos"
       "graffiti" "graffiti" "mackerel" "mackerel" "succubus" "succubi"
       "apparatus" "apparatus" "armadillo" "armadillos" "vertebra" "vertebrae"
       "wildebeest" "wildebeest" "candelabrum" "candelabra"
       "headquarters" "headquarters")
   by #'cddr do (setf (gethash word *irregular-words*) plural))

(defparameter *irregular-suffixes* 
  '(("ch" . "ches") ("sh" . "shes") ("ss" . "sses") ("alf" .  "alves")
    ("elf" . "elves") ("olf" . "olves") ("eaf" . "eaves") ("arf" . "arves")
    ("ois" . "ois") ("eau" . "eaux") ("ieu" . "ieux") ("inx" . "inges")
    ("anx" . "anges") ("ynx" . "ynges") ("oof" . "ooves") ("nife" . "nives")
    ("wife" . "wives") ("fish" . "fish") ("deer" . "deer") ("pox" . "pos")
    ("itis" . "itis") ("trix" . "trices") ("sheep" . "sheep")))


(defun pluralise-word (orig-word)
  "Turn WORD into its plural form."
  (let* ((word (string-downcase orig-word)) (word-length (length word)))
    (flet ((last-letter (num)
	     (schar word (- word-length num))))
      (or (when (< word-length 2) word)
	  ;; 1. is the word irregular?
	  (gethash word *irregular-words*)

	  ;; 2. does it have an irregular suffix?
	  (bif found (find-if #'(lambda (suffix)
				  (and (>= word-length (length (car suffix)))
				       (string= (car suffix) word :start2
						(- word-length (length (car suffix))))))
			      *irregular-suffixes*)
	       (strcat (subseq word 0 (- word-length (length (car found)))) (cdr found)))

	  ;; 3. *[aeiou]y => *[aeiou]ys, else *y => *ies
	  (when (char= (last-letter 1) #\y)
	    (if (vowelp (last-letter 2))
		(strcat word "s")
		(strcat (subseq word 0 (1- word-length)) "ies")))

	  ;; 4. *[aeiou]o => *[aeiou]os, else *o => *oes
	  (when (char= (last-letter 1) #\o)
	    (strcat word (if (vowelp (last-letter 2)) "s" "es")))

	  ;; 5. *[aeiou][xs] => *es
	  (when (and (find (last-letter 1) "sx") (vowelp (last-letter 2)))
	    (strcat word "es"))

	  ;; 6. * => *s"
	  (strcat word "s")))))


(defun pluralise-string (string &optional numbers)
  (flet ((next-number ()
	   (or (and (functionp numbers) (funcall numbers))
	       (and (numberp numbers) numbers)
	       (and (consp numbers) (pop numbers))
	       1)))
    (loop
       with result = ""
       for length = (length string)
       for hashmark = (or (position #\# string)
			  length)
       for delim = (or (position-if #'punctuationp string :start hashmark)
		       length)
       do (setf result (strcat result (subseq string 0 hashmark)))
       until (eql hashmark length)
       do (setf result (strcat result (if (= (next-number) 1)
					  (subseq string (1+ hashmark) delim)
					  (pluralise-word (subseq string
								  (1+ hashmark)
								  delim))))
		string (subseq string delim))

       finally (return-from pluralise-string result))))
      

(defun indefinite-article (string)
  (if (vowelp (schar string 0)) "an" "a"))


(defun specify-string (string number &optional definite)
  (let ((text (pluralise-string string number)))
    (strcat (cond
	      (definite "the")
	      ((= number 1) (indefinite-article text))
	      (t (princ-to-string number)))
	    " "
	    text)))

(defvar *personal-pronouns* '(:male "he" :female "she" :neuter "it"))
(defvar *pronouns* '(:male "him" :female "her" :neuter "it"))
(defvar *possessives*'(:male "his" :female "her" :neuter "its"))
(defvar *reflexives* '(:male "himself" :female "herself" :neuter "iteself"))


(defparameter *last-acc* nil)
(defparameter *last-nom* nil)

(defun reset-grammar ()
  (setf *last-acc* nil
	*last-nom* nil))

(defun @n (nominative &optional (follow-with " "))
  (list :nom nominative follow-with))

(defun @a (accusative &optional (follow-with " "))
  (list :acc accusative follow-with))

(defun @d (dative &optional (follow-with " "))
  (list :dat dative follow-with))

(defun @g (owner &optional (follow-with " "))
  (list :gen owner follow-with))

(defun @v (verb &optional (follow-with " "))
  (list :verb verb follow-with))

(defun grammarp (obj)
  (and (listp obj) (member (car obj) '(:nom :acc :dat :gen :verb))))

(defun format-sentence (viewer &rest phrases)
  (labels ((make-possessive (w &aux (last-char (char w (1- (length w)))))
	     (strcat w (if (find last-char "sxz") "'" "'s")))
	   
	   (make-grammar (phrase)
	     (strcat
	      (let* ((obj (second phrase))
		     (viewer? (eq obj viewer))
		     (nom? (eq obj *last-nom*))
		     (acc? (eq obj *last-acc*)))
		(case (first phrase)
		  (:nom
		   (setf *last-nom* obj)
		   (cond
		     (viewer? "you")
		     (acc? (getf *personal-pronouns* (gender obj)))
		     (t (describe obj))))
		  (:gen
		   (cond
		     (viewer? "your")
		     ((or acc? nom?) (getf *possessives* (gender obj)))
		     (t (make-possessive obj))))
		  (:verb
		   (if (eq *last-nom* viewer) obj (pluralise-word obj)))
		  (t
		   (setf *last-acc* obj)
		   (cond
		     ((and viewer? nom?) "yourself")
		     (viewer? "you")
		     (nom? (getf *reflexives* (gender obj)))
		     (acc? (getf *pronouns* (gender obj)))
		     (t (pluralise-word (describe obj)))))))
	      (bif follow-with (third phrase) follow-with "")))
	   
	   (make-phrase (p)
	     (cond
	       ((grammarp p) (make-grammar p))
	       ((or (colourp p) (stringp p)) p)
	       (t (string p)))))

    (reduce-adjacent (lambda (a b) (and (stringp a) (stringp b)))
		     #'strcat 
		     (mapcar #'make-phrase phrases))))


;;;============================================================================
;;; Dice rolling
;;;============================================================================

(defun dice-n (sides)
  (declare (type number sides))
  (1+ (random sides)))


(defun dice (dice &key maximise minimise average)
  (declare (type string dice))
  (labels ((operator-p (char)
	     (find char "Dd^*/%+-mM\("))

	   (prec (char)
	     (getf '(#\D 10 #\^ 9 #\* 8 #\/ 8 #\% 8 #\+ 6 #\- 6 #\M 4 #\()
		   (char-upcase char) 
		   nil))

	   (roll (num sides)
	     (cond
	       (maximise sides)
	       (minimise 1)
	       (average (+ (/ sides 2) 1/2))
	       (t (loop repeat num summing (1+ (random sides))))))

	   (operator (char)
	     (getf `(#\d #'roll #\D ,#'roll #\^ ,#'expt #\* ,#'* #\/ ,#'floor
		     #\% ,#'rem #\+ ,#'+ #\- ,#'- #\m ,#'min #\M ,#'max)
		   char
		   #'roll)))

    ;; Shunting algorithm from
    ;; http://montcs.bloomu.edu/~bobmon/Information/RPN/infix2rpn.shtml
    (let ((operators nil)
	  (inputq (make-queue))
	  (output nil))

      (loop
	 with length = (length dice)
	 for char-idx from 0
	 for char = (if (< char-idx length) (schar dice char-idx) #\Space)
	 while (< char-idx (length dice))
	 do (cond
	      ((digit-char-p char) (multiple-value-bind (num idx)
				       (parse-integer dice :start char-idx
						      :junk-allowed t)
				     (queue-push num inputq)
				     (setf char-idx (1- idx))))
	      ((operator-p char) (loop with prec = (prec char)
				    while (and (car operators)
					       (< prec (prec (car operators))))
				    do (queue-push (pop operators) inputq)
				    finally (push char operators)))
	      ((char= char #\() (push #\( operators))
	      ((char= char #\)) (loop until (or (null (car operators))
						(char= (car operators) #\())
				   do (queue-push (pop operators) inputq)
				   finally (pop operators)))      
	      (t (error "Unexpected character ~A in (dice)" char)))
	   
	 finally (dolist (o operators)
		   (queue-push o inputq)))

      (loop for token = (queue-pop inputq)	   
	 while token
	 do (if (numberp token)
		(push token output)
		(let ((right (pop output)) (left (pop output)))
		  (push (funcall (operator token) left right) output))))
      (floor (pop output)))))

;;;============================================================================
;;; Path finding
;;;============================================================================

(defun manhattan-distance (from to)
  (max (abs (- (car to) (car from))) (abs (- (cdr to) (cdr from)))))

(defun regular-distance (from to)
  (sqrt (float (+ (expt (- (car from) (car to)) 2)
		  (expt (- (cdr from) (cdr to)) 2)))))

(defstruct (node (:constructor
		  make-node (coords parent cost-here cost-goal cost-total)))
    coords
    parent
    cost-here
    cost-goal
    cost-total)


(defun add/update-open (coords parent cost-here target-pos open)
  (declare (type (cons fixnum fixnum) coords target-pos)
	   (type fixnum cost-here))
  (bif item (heap-find coords open :key #'node-coords :test #'equal)
       (when (< cost-here (node-cost-here item))
	 (setf (node-cost-here item) cost-here
	       (node-cost-total item) (+ cost-here (node-cost-goal item))
	       (node-parent item) parent)
	 (heap-re-heapify open))
       (let ((cost-goal (manhattan-distance coords target-pos)))
	 (heap-push (make-node coords parent cost-here  cost-goal
			       (+ cost-here cost-goal)) open))))

(defun add-closed (node closed)
  (setf (gethash (node-coords node) closed) node))

(defun in-closed-p (coords closed)
  (declare (type (cons fixnum fixnum) coords))
  (gethash coords closed))

(defun next-open (open closed)
  (do ((c (heap-pop open) (heap-pop open)))
      ((or (null c) (not (gethash (node-coords c) closed))) c)))

(defun trace-back (end)
  (loop
     with path = nil
     for pos = end then (node-parent pos)
     while (and pos (node-parent pos))
     do (push (node-coords pos) path)
     finally (return path)))

(defun path-find (start target passable-p in-map-bounds-p &aux
		  (start-pos (copy-tree start)) (target-pos (copy-tree target)))
  (declare (type (cons fixnum fixnum) start-pos target-pos))
  (let ((open   (make-heap :key #'node-cost-total))
	(closed (make-hash-table :test #'equal))
	(offsets '((-1 -1) (0 -1) (1 -1) (-1 0) (1 0) (-1 1) (0 1) (1 1))))
       
    (add/update-open start-pos nil 0 target-pos open)
    (loop
       for current = (next-open open closed)
       while current
       do (add-closed current closed)	   
       until (or (null current)
		 (equal (node-coords current) target-pos))
       do (loop
	     for offset in offsets
	     for adjusted = (apply #'adj-coords current offset)
	     when (and (funcall in-map-bounds-p adjusted)
		       (funcall passable-p adjusted)
		       (not (in-closed-p adjusted closed)))
	     do (add/update-open adjusted
				 current
				 (1+ (node-cost-here current))
				 target-pos
				 open))
       finally (return (trace-back current)))))



(defun trace-line (from to)
  (declare (type (cons fixnum fixnum) from to))  
  (let* ((from-x (car from)) (from-y (cdr from))
	 (to-x (car to)) (to-y (cdr to))
	 (steep (> (abs (- to-y from-y))
		   (abs (- to-x from-x)))))
    (when steep
      (rotatef to-x to-y)
      (rotatef from-x from-y))
        
    (loop
       with delta-x = (abs (- to-x from-x))
       with delta-y = (abs (- to-y from-y))
       with error = 0
       with deltaerr = delta-y
       with cur-pos = (cons from-x from-y)
       with x-step = (if (< from-x to-x) 1 -1)
       with y-step = (if (< from-y to-y) 1 -1)

       until (= (car cur-pos) to-x)
       collect (progn
		 (incf (car cur-pos) x-step)
		 (incf error deltaerr)
		 (when (>= (* 2 error) delta-x)
		   (incf (cdr cur-pos) y-step)
		   (decf error delta-x))
		 (if steep
		     (cons (cdr cur-pos) (car cur-pos))
		     (cons (car cur-pos) (cdr cur-pos)))))))


